00100	C  THIS PROGRAM CREATES FUNCTIONS FOR THE MUSIC PROGRAM USING 
00200	C  'SEG' OR 'SYNTH'.  UP TO 10 FUNCTIONS CAN BE STORED IN A
00300	C  SINGLE FILE.  ONCE CREATED, THE FUNCTIONS MAY BE CHANGED
00400	C  AND PUT BACK IN THE SAME FILE OR INTO A NEW ONE.
00500	C  NO MORE THAN 50 INPUTS FOR ONE FUNCTION!
00600	C TYPE 'C'(= CRUNCH)  FOR SPECIAL FEATURE SUBR TO COMBINE FUNCS 
00665	C ALREADY MADE.      [MULT, ADD, RETRO, INVRT, ADD CONSTANT ]
00730	
00795	C  SEG FUNCS MAY BE 'SMOOTHED' BUT THIS FEATURE AND 'CRUNCH' SHOULD 
00860	C  BE USED SPARINGLY AS ALL 512 WDS OF THE ARRAY MUST BE SAVED.  THIS
00925	C  CLUTTERS UP THE DSK.
00990	
01055	C  'Z' FOR "CHANGE OR FINISH?" WILL JUMP DIRECTLY TO "CRUNCH" MODE.
01120	C    BUT ONCE CHANGED BY 'CRUNCH' THIS UNSTORED ORIG. IS LOST.
01200	C  'SP' (FOR "SEE") WILL PLOT ONE AT A TIME.
01228	C  'SA' PLOTS ALL IN .DAT FILE ON CALCOMP
01256	C  'SX' PLOTS ALL IN XGP FORMAT. (1ST→ <CTRL C>, A DSK PTP  --
01284	C -- WHEN DONE→ <CTRL C>, F )  THEN USE "X" PROG. TYPE 6,11,1.
01315	
01380	C FOR EXPONENTIALS GET INTO 'SEG'.  TYPE 'X', DECAY FAC, N.  IF 
01445	C  N IS NON-ZERO THE FUNCTION WILL NOT! NORMALIZE (IE. NOT GO TO 0).
01575	C  THE DECAY FAC. IS THE NUM ALONGTHE SCALE(1-100) WHERE THE CURVE
01640	C  SEEMS TO TOUCH ZERO. (WILL ALWAYS HIT 0 AT END UNLESS N.NE.0.)
01705	
01710	C AFTER FILE IS READ IN, <CR> FOR 'TYPE FILE' WILL HOLD ON TO IT.
01835	C  LOAD WITH -- WRIFUN,FUSUB,DFUNC,SSS,MSFAIL.FAI (+RANFIL.MAC?)
01900		COMMON/S/H,AMP,CON,PH /GRD/ON
02000		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
02100		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
02200		COMMON FUNC(512),F2(512),K,I
02300		DIMENSION RF(4)
02400	21	FORMAT(' C=CHANGE, F=FINISH  '$)
02500	22	FORMAT(' NEW FUNC, EDIT, CRUNCH, DELETE, RENAME, SEE?   '$)
02600	23	FORMAT(' SEG OR SYNTH?   '$)
02800	25	FORMAT(' TYPE FILE NAME   '$)
02900	26	FORMAT(I3,') TYPE AMPL, STEP# -- OR L=LTPEN   '$)
03000	C  'X' HERE WILL MAKE EXPON. FUNC.
03100	28	FORMAT(' 0=NORM,OR H,A,P,K   '$)
03200	280	FORMAT(' NEW VERSION!  --REPORT ANY PROBLEMS TO LCS'/
03300		1' UP TO 10 FUNCTIONS MAY BE STORED IN EACH FILE'/
03400		1' TYPE "B" TO BACKUP AT ANY TIME'//)
03500	30	FORMAT(8F)
03600	31	FORMAT(1XA5,A1,5A5/)
03800	35	FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
03900	37	FORMAT(8F9.3)
04000	371	FORMAT(I3,') ',4F8.2)
04100	372	FORMAT(I,21F)
04200	38	FORMAT(2(A5,A1),23A2)
04300	40	FORMAT(11(A1,A3))
04400	41	FORMAT(' ADD TO AN EXISTING FILE?   '$)
04500	42	FORMAT(' WHICH FUNC?   '$)
04600	47	FORMAT(' C=CHNG, I=INSRT, D=DEL -- + LN# & CHNGS '$)
04700	48	FORMAT(' X,N(=DECAY FAC.) FOR XPONTLS')
04800	2281	TYPE 280
04900	281	KZ=0
05000	C   USED IN RELATIVE VECTOR ROUTINE
05100		Z=0
05200		XZ=0
05300		EY=0
05400		ICUR=0
05500		XP=0
05600		KT=0
05700		FNUM=0
05800		OLD=0
05900		FNUM1=0
06000		TYPE 22
06100		ACCEPT 40,ON,P
06200		PLTALL=0
06300	C75	IF(P.EQ.'A'.OR.P.EQ.'X')PLTALL=-1
06310		IF(P.EQ.'A')GO TO 3280
06320		IF(P.NE.'X')GO TO 1281
06330	3280	PLTALL=-1
06400	1281	IPLOT=0
06500		XDPY=-1
06505		IF(ON.EQ.'N')GO TO 1000
06507		IF(ON.EQ.'E')GO TO 100
06509		IF(ON.EQ.'R')GO TO 100
06519		IF(ON.EQ.'D')GO TO 100
06527		IF(ON.EQ.'C')GO TO 100
06537		IF(ON.EQ.'S')GO TO 100
06538	CC 7/74 COLGATE	ON=ONX
06549	C ---OUT 7/74---  RETURNS FOR MORE "SEE"
06560	CC 7/74 COLGATE	GO TO 4281
06571		GO TO 281
06582	C  WON'T GO ON IF BLANK
06600	C75	IF(ON.EQ.'N'.OR.(ON.EQ.' '.AND.ONX.NE.'S'))GO TO 1000
06700	C75	IF(ON.NE.' ')GO TO 100
06800	C75	ON=ONX
06900		XDPY=0
07000	C  <CR> FOR 'SEE' WILL DISPLAY UP TO 3 FUNCS AT ONCE.
07100	C  RETURNS FOR MORE "SEE"
07200	C75	GO TO 4281
07300	100	ONX=ON
07400		TYPE 25
07500		OLD=-1
07600		ACCEPT 38,FLNM1
07700		IF(FLNM1.EQ.' ')FLNM1=FLNM
07800		IF(FLNM1.EQ.0)GO TO 100
07805		IF(LOOKD(FLNM1).EQ.0)GO TO 100
07900		IF(FLNM.NE.FLNM1)GO TO 2151
08000		OLD=0
08100	4281	TYPE 40,B
08200		IF(PLTALL)GO TO 5402
08300		GO TO 1402
08400	2151	FLNM=FLNM1
08500		CALL READ1
08600	3402	LX=0
08700		TYPE 40,B
08800		IF(PLTALL)GO TO 402
08900	C  "SA" WILL PLOT ALL FUNCS IN FILE
09000		JX=-1
09100		IF(B(1,2).NE.' ')GO TO 1402
09200		FNUM1=B(2,1)
09300	C  ONLY ONE FUNC IN FILE.
09400		GO TO 402
09500	1402	TYPE 42
09600		ACCEPT 40,BU
09650		IF(BU.EQ.' ')GO TO 1402
09700		IF(BU.NE.'B')GO TO 380
09740		FLNM=0
09780		JX=0
09820		GO TO 281
09860	380	REREAD 38,FNUM1
09900		IDEL=0
10000	C  LX IS MAIN COUNTER
10100		IF(OLD)GO TO 402
10200		DO 1302 JX=1,10
10300	1302	IF(FNUM1.EQ.FN(JX))GO TO 5402
10400	C75	GO TO 3402
10450		GO TO 100
10500	402	CALL READER
10550		IF(JX)GO TO 100
10575	C 6/74  GO BACK IF IT DIDN'T FIND THE FUNC NAME IN THIS FILE.
10600	C  AT THIS POINT LX=TOTAL FUNCS+1
10700	5402	IF(PLTALL)JX=1
10800	1202	IF(ON.EQ.'C')GO TO 3202
10810		IF(ON.EQ.'S')GO TO 3202
10820		IF(ON.NE.'D')GO TO 3281
10900	3202	IF(XDPY)CALL DPYX(1)
11000		CALL DPYF(JX,FUNC)
11100		IF(PLTALL)GO TO 2202
11110		IF(P.EQ.'P')GO TO 2202
11120		IF(P.EQ.0)GO TO 2202
11200		IF(ON.EQ.'S')GO TO 2281
11300		IF(ON.EQ.'C')GO TO 1201
11400	1140	TYPE 1139
11500		ACCEPT 40,IDEL
11600		IF(IDEL.EQ.'N')GO TO 2281
11610		IF(IDEL.NE.'Y')GO TO 1140
11700		IDEL=JX
11800		LX=LX-1
11900	C  NOW LX=TOTAL # OF FUNCS.
12000		CALL WRIFUN
12100	1139	FORMAT(' DELETE IT? ',$)
12200	2202	CALL PLOTIT(FUNC,XA(JX),P)
12300		IF(P.EQ.'P')GO TO 2281
12400		JX=JX+1
12450		FNUM1=B(2,JX)
12480	C75	IF(FNUM1.EQ.' ')GO TO 2281
12500		IF(FNUM1.EQ.' ')GO TO 4202
12505		IF(JX.LE.10)GO TO 1202
12600	C  "SA" KEEPS PLOTTING UNTIL NO MORE ARE FOUND
12700	C75	GO TO 2281
12725	4202	CALL DDCLR
12750		CALL EXIT
12800	3281	X=' '
12900		TYPE 31,XA(JX),X,FN(JX)
13000		JT=4
13100		IF(XA(JX).EQ.'SEG')JT=2
13200		KZ=1
13300		DO 137	K=1,50
13400		KZ=KZ+1
13500		DO 138 L=1,JT
13600	138	A(K,L)=AA(L,K,JX)
13700		IF(A(K,1).EQ.999)GO TO 4401
13710	137	IF(A(K,2).GE.100)GO TO 4401
13800	
13900	4401	Z=-1
14000		IF(A(K,2).LE.100)GO TO 4403
14100		IF(K.GT.1)GO TO 4404
14200		CALL DPYX(1)
14300		CALL DPYF(JX,FUNC)
14400		IF(ON.EQ.'R')GO TO 3032
14500		TYPE 4405
14600		A(1,2)=520
14700		GO TO 4201
14800	4404	TYPE 4402
14900	4403	IF(JT.EQ.2)EY='EG'
15000		GO TO 1032
15100	4402	FORMAT('  IT WAS SMOOTHED.')
15200	4405	FORMAT(' CANNOT EDIT CRUNCHED FUNCS.'/)
15300	1000	TYPE 23
15400		ACCEPT 40,BU
15500		IF(BU.EQ.'B')GO TO 281
15600		REREAD 40,X,EY
15700	1032	CALL ZERO(FUNC)
15800	C  CLEARS THE FUNC.
15900		ISMOO=0
16000		IF(EY.EQ.'EG')GO TO 800
16100	151	EY=0
16200		JT=4
16300	C  FOR WRIFUN
16400	1031	CALL DPYX(1)
16500	15	KT=1
16600	104	IF(Z.EQ.-1)GO TO 102
16610		IF(KT.LT.KZ)GO TO 102
16700		IF(Z.EQ.1)GO TO 2032
16800	1041	KZ=0
16900		TYPE 28
16950		Z=0
17000		ACCEPT 40,BU
17100		IF(BU.EQ.'B')GO TO 509
17200		REREAD 30,(A(KT,K),K=1,4)
17300	C ACCEPT HARM,AMPL,PHASE,KONSTANT(IF K>100, MULTIPLIES WAVE *(K-100))
17400	102	H=A(KT,1)
17500		IF(H.EQ.0)GO TO 2200
17510		IF(H.EQ.999.)GO TO 2200
17600	C   999 ENDS 'READIN' SYNTHS
17700		IF(Z.GT.0)TYPE 371,KT,(A(KT,K),K=1,4)
17800		AMP=A(KT,2)
17900		PH=A(KT,3)
18000		CON=A(KT,4)
18100		CALL SYN(FUNC)
18200		KT=KT+1
18300		IF(KZ.LE.KT)CALL DPY(FUNC,1)
18400		GO TO 104
18500	2201	IF(JT.NE.2)GO TO 1201
18510		IF(A(KT-1,2).GT.100)GO TO 1201
18600	C  TO USE CURRENT FUNC IN CRUNCH
18700		IF(LX.GT.10)GO TO 204
18800		CALL STORE(10)
18900	C  PUTS FROM A ARRAY TO AA ARRAY
19000		XA(K)='SEG'
19100		CALL DPYX(1)
19200		CALL DPYF(10,FUNC)
19300	1201	CALL ZFUNC
19400	C  THIS WILL BE FOR SPECIAL FEATURE PACKAGE
19500		IF(KT.EQ.512)GO TO 2281
19600	C  FOR BACKUP
19700	4201	EY='EG'
19800		KT=2
19900		GO TO 900
20000	 2200	CALL NORM(FUNC)
20100	C   NORMALIZES THE FUNCTION
20200		CALL DPY(FUNC,1)
20300	 201	IF(BU.EQ.'C')GO TO 2032
20400		IF(ON.EQ.'R')GO TO 3032
20500	204	TYPE 21
20600		IF(EY.EQ.'EG')TYPE 271
20700	C   CHANGE IT?
20800		ACCEPT 40,BU
20900		IF(BU.EQ.'C')GO TO 210
21000		IF(BU.EQ.'F')GO TO 900
21100		IF(BU.EQ.'S')GO TO 7000
21200		IF(BU.EQ.'Z')GO TO 2201
21300	C  TO USE CURRENT FUNC IN CRUNCH
21400		IF(BU.NE.'B')GO TO 2032
21500		IF(EY.EQ.'EG')GO TO 509
21600		GO TO 5091
21700	C   NEXT IS FOR CHANGES ('C' OR <CR>)
21800	2032	TYPE 47
21900		ACCEPT 40,K
22000		REREAD 372,L,X,RF
22100		IF(X.NE.0)GO TO 211
22110		IF(RF(1).NE.0)GO TO 211
22200		IF(EY.EQ.'EG')GO TO 204
22300		BU=0
22400		GO TO 1041
22500	211	L=X
22600		IF(K.EQ.'I')GO TO 212
22700		IF(K.NE.'D')GO TO 205
22800	C   JUMP IF NO DELETE
22900		KT=KT-1
23000		DO 209 K=L,KT
23100		DO 209 J=1,4
23200	209	A(K,J)=A(K+1,J)
23300		GO TO 210
23400	205	X=RF(2)
23500		IF(EY.NE.'EG')GO TO 1207
23600		IF(X.LT.A(L+1,2))GO TO 208
23610		IF(L.LT.KT-1)GO TO 2032
23700		GO TO 208
23800	212	IF(RF(2).NE.0)GO TO 213
23900		RF(2)=RF(1)
24000		RF(1)=X
24100		L=KT
24200	213	IF(EY.NE.'EG')GO TO 214
24300		X=RF(2)
24400		DO 215 K=1,KT
24500		Y=A(K,2)
24600		IF(X.GT.Y)GO TO 215
24700	C   JUMP IF NOT PAST STEP NUM.
24800		L=K
24900		IF(X.EQ.Y)GO TO 208
25000	C   IF STEP=ANOTHER STEP, IT WORKS LIKE 'C'HANGE.
25100		GO TO 214
25200	215	CONTINUE
25300	214	KT=KT+1
25400		DO 206 K=KT,L,-1
25500		DO 206 J=1,4
25600	206	A(K,J)=A(K-1,J)
25700		GO TO 207
25800	C   TO TYPE OLD NUMBERS
25900	208	IF(X.GT.A(L-1,2))GO TO 1207
25910		IF(L.GT.1)GO TO 2032
26000	1207	TYPE 371,L,(A(L,K),K=1,4)
26100	207	DO 202 K=1,4
26200	202	A(L,K)=RF(K)
26300	210	KZ=KT
26400		Z=1
26500		GO TO 1032
26600	271	FORMAT('+S=SMOOTH  '$)
26700	C  FOR RENAMES
26800	3032	Z=-1
26900		GO TO 901
27000	900	TYPE 41
27100	C  ADD TO EXISTING FILE
27200		ISKP=0
27300		ACCEPT 40,Z
27400	9000	IF(Z.EQ.'B')GO TO 204
27500		IF(Z.EQ.'Y')GO TO 9001
27510		IF(Z.NE.'N')GO TO 900
27600	9001	TYPE 25
27700		ACCEPT 38,FLNM
27800		IF(FLNM.NE.' ')GO TO 9002
27810		IF(FLNM1.NE.' ')FLNM=FLNM1
27900	9002	IF(FLNM.EQ.'B')GO TO 204
27910		IF(FLNM.EQ.' ')GO TO 204
28000	CC	IF(LOOKD(FLNM).AND.Z.EQ.'N')GO TO 902
28100		IF(LOOKD(FLNM))GO TO 902
28200		IF(Z.NE.'N')GO TO 900
28300	C  LOOKD CHECKS ON LOOK-UP
28400	901	JT=4
28500		IF(EY.EQ.'EG')JT=2
28550		IDEL=0
28600		CALL WRIFUN
28700		GO TO 900
28800	C  COMES BACK IF NO ROOM IN FILE FOR NEW FUNC.
28900	902	IF(Z.NE.'N')GO TO 901
29000		TYPE 381,FLNM
29100		ACCEPT 40,Z
29200	C75	IF(Z.NE.'N')GO TO 901
29300	C75	GO TO 9000
29400	C75 381	FORMAT(' WRITE OVER ',A5,'.DAT?  ',$)
29405		IF(Z.EQ.'Y')GO TO 903
29416		GO TO 9000
29427	903	Z='N'
29438		GO TO 901
29449	C  7/74 COLGATE  NOW WILL REALLY WRITE OVER A FILE!
29460	381	FORMAT(/9X'WRITE OVER ',A5,'.DAT?  ',$)
29500	
29600	161	DO 261 K=1,512
29700	261	FUNC(K)=EXP((1-K)/STEP)
29800		KT=2
29900		XP=-1
30000		IF(H.NE.0)GO TO 7009
30100	C  H≠0 = NO NORMALIZATION OF XPONTL
30200		X=FUNC(512)
30300		DO 361 K=1,512
30400	361	FUNC(K)=FUNC(K)-(K-1)/511.*X
30500		GO TO 7009
30600	800	IF(XP)GO TO 510
30700		X=0
30800		JT=2
30900	C  JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
31000		Y=0
31100		KT=1
31200		N=-256
31300		CALL DPYX(2)
31400		CALL DPYBRT(5)
31500	504	IF(KT.GE.KZ)GO TO 510
31600		AMP=A(KT,1)
31700	5008	STEP=A(KT,2)
31800		IF(STEP.GT.A(KT-1,2))GO TO 5071
31810		IF(KT.GT.1)GO TO 509
31900	C   SO IT CAN'T GO BACKWARDS
32000		GO TO 5071
32100	434	ICUR=0
32200		CALL CLRCUR
32300		GO TO 510
32400	C   EXIT FROM CURSOR
32500	CC431	CALL SETCUR(-256,128,0)
32600	431	NX=-256
32700		NY=128
32800		NZ=0
32900	C  TYPE <CR> HERE TO SET FIRST POINT AT 0,0
33000		ICUR=-1
33100	433	CALL SETCUR(NX,NY,NZ)
33200		NZ=1
33300	C  =1 TO DRAG ALONG VECTOR
33400		TYPE 432,KT
33500		ACCEPT 40,AB
33600		IF(AB.EQ.'B')GO TO 509
33700		IF(AB.EQ.'R')GO TO 434
33800		MX=NX
33900		MY=NY
34000		CALL RDCUR(NX,NY)
34100	CC	CALL SETCUR(NX,NY,1)
34200		STEP=(NX+256)/5.12
34300		AMP=(NY-128)/256.
34400		IF(KT.EQ.1)STEP=1.
34500		IF(STEP.LT.100)GO TO 5571
34600		AMP=((STEP-100)/(STEP-A(KT-1,2)))*(A(KT-1,1)-AMP)+AMP
34700		ICUR=0
34800		CALL CLRCUR
34900		STEP=100.
35000	5571	TYPE 37,AMP,STEP
35100		GO TO 5071
35200	611	FORMAT(' NO MORE THAN 50 SEGS'/)
35300	610	TYPE 611
35400	509	KT=KT-1
35500	CC	IF(ICUR)CALL SETCUR(MX,MY,1)
35600	5091	IF(KT.LT.1)GO TO 281
35700		GO TO 210
35800	432	FORMAT(I3,') <CR>=SEG, B=BACKUP, R=RETURN  '/)
35900	510	IF(ICUR)GO TO 433
36000		IF(KT.EQ.1)TYPE 48
36100		TYPE 26,KT
36200		KZ=0
36300		ACCEPT 40,BU
36400		IF(BU.EQ.'B')GO TO 509
36500		IF(BU.EQ.'L')GO TO 431
36600	61	REREAD 30,AMP,STEP,H
36700		IF(STEP.LT.1)STEP=1
36800		IF(BU.EQ.'X')GO TO 161
36900	C  TYPE 'X' FOR EXPON. FUNC. + DECAY FACTOR, +1 = NO NORM.
37000	C  WE START WITH STEP 1 (NOT 0)
37100	5071	IF(KT.GT.50)GO TO 610
37200	C   TOO MANY SEGS
37300		IF(Z.GT.0)TYPE 371,KT,AMP,STEP
37400		IF(STEP.GT.100)STEP=100
37500		DIF=AMP-Y
37600		IF(STEP-X.GT.0)GO TO 9003
37610		IF(KT.NE.1)GO TO 504
37700	C   SO IT CAN'T BACKUP HERE
37800	9003	IF(STEP.LE.1.)Y=AMP
37900	203	YSTP=STEP
38000		IF(YSTP.GT.1)GO TO 1203
38100		YSTP=0
38200		X=-1
38300	1203	JJX=X*5.120-256
38400		NX=YSTP*5.120-256
38500		NY=AMP*256.+128.
38600		IZ=Y*256.+128.
38700		CALL ALINE(JJX,IZ,NX,NY)
38800		CALL DPYOUT(1)
38900	12	Y=AMP
39000		X=YSTP
39010		IF(KT.GT.1)GO TO 404
39020		IF(STEP.LE.1)GO TO 404
39025	C  PUTS 0,0 IN IF 1ST STEP IS NOT 1 OR 0
39030		A(1,1)=0
39040		A(1,2)=0
39050		KT=2
39100	404	A(KT,1)=Y
39200	CC	A(KT,2)=X
39300		A(KT,2)=STEP
39400	7001	KT=KT+1
39500	C   KT COUNTS SEGMENTS
39600		IF(STEP.LT.100)GO TO 504
39700		GO TO 201
39800	
39900	7000	IF(ISMOO)GO TO 201
40000		IF(KT.LE.20)GO TO 7007
40100		TYPE 7008
40200		GO TO 509
40300	7008	FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
40400	7007	CALL SSS(A,KT-1,FUNC)
40500	C   DRAWS GRID 2
40600	 7009	CALL DPY(FUNC,2)
40700		A(KT-1,2)=520
40800		ISMOO=-1
40900	C  SO YOU CAN'T COME BACK 2 TIMES
41000		GO TO 201
41100		END